home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / dlap.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  19.9 KB  |  536 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30.  
  31.  
  32. (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p))
  33. (defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p))
  34.  
  35. (defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p))
  36. (defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p))
  37.  
  38.  
  39.  
  40. (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
  41.   (declare (type index   1-or-2-class)
  42.            (type boolean class-slot-p))
  43.   (let ((instance nil)
  44.     (arglist  ())
  45.     (closure-variables ())
  46.     (field (first-wrapper-cache-number-index)))               ;we need some field to do
  47.                                    ;the fast obsolete check
  48.     (ecase reader/writer
  49.       (:reader (setq instance (dfun-arg-symbol 0)
  50.              arglist  (list instance)))
  51.       (:writer (setq instance (dfun-arg-symbol 1)
  52.              arglist  (list (dfun-arg-symbol 0) instance))))
  53.     (ecase 1-or-2-class
  54.       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
  55.       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
  56.     (generating-lap closure-variables
  57.             arglist
  58.        (with-lap-registers ((inst t)                   ;reg for the instance
  59.                 (wrapper #-structure-wrapper vector       ;reg for the wrapper
  60.                      #+structure-wrapper t)
  61.                 #+structure-wrapper (cnv fixnum-vector)
  62.                 (cache-no index))               ;reg for the cache no
  63.       (let ((index cache-no)                   ;This register is used
  64.                                    ;for different values at
  65.                                    ;different times.
  66.         (slots (and (null class-slot-p)
  67.                 (allocate-register 'vector)))
  68.         (csv   (and class-slot-p
  69.                 (allocate-register t))))
  70.         (prog1 (flatten-lap
  71.              (opcode :move (operand :arg instance) inst)   ;get the instance
  72.              (opcode :std-instance-p inst 'std-instance)   ;if not either std-inst
  73.              (opcode :fsc-instance-p inst 'fsc-instance)   ;or fsc-instance then
  74.                      #+pcl-user-instances
  75.              (opcode :user-instance-p inst 'user-instance) ;if not either std-inst
  76.              (opcode :go 'trap)                   ;we lose
  77.  
  78.                      #+pcl-user-instances
  79.              (opcode :label 'user-instance)
  80.                      #+pcl-user-instances
  81.              (opcode :move (operand :user-wrapper inst) wrapper)
  82.                      #+pcl-user-instances
  83.              (and slots
  84.               (opcode :move (operand :user-slots inst) slots))
  85.                      #+pcl-user-instances
  86.              (opcode :go 'have-wrapper)
  87.  
  88.              (opcode :label 'fsc-instance)
  89.              (opcode :move (operand :fsc-wrapper inst) wrapper)
  90.              (and slots
  91.               (opcode :move (operand :fsc-slots inst) slots))
  92.              (opcode :go 'have-wrapper)
  93.  
  94.              (opcode :label 'std-instance)
  95.              (opcode :move (operand :std-wrapper inst) wrapper)
  96.              (and slots
  97.               (opcode :move (operand :std-slots inst) slots))
  98.  
  99.              (opcode :label 'have-wrapper)
  100.              #-structure-wrapper
  101.              (opcode :move (operand :cref wrapper field) cache-no)
  102.              #+structure-wrapper
  103.              (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
  104.              #+structure-wrapper
  105.              (opcode :move (operand :cref cnv field) cache-no)
  106.              (opcode :izerop cache-no 'trap)           ;obsolete wrapper?
  107.  
  108.              (ecase 1-or-2-class
  109.                (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 'trap))
  110.                (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 'wrapper-1 'trap)))
  111.              
  112.              (if class-slot-p
  113.              (flatten-lap
  114.               (opcode :move (operand :cvar 'index) csv)
  115.               (ecase reader/writer
  116.                (:reader (emit-get-class-slot csv 'trap inst))
  117.                (:writer (emit-set-class-slot csv (car arglist) inst))))
  118.                (flatten-lap
  119.             (opcode :move (operand :cvar 'index) index)
  120.             (ecase reader/writer
  121.                (:reader (emit-get-slot slots index 'trap inst))
  122.                (:writer (emit-set-slot slots index (car arglist) inst)))))
  123.           
  124.              (opcode :label 'trap)
  125.              (emit-miss 'miss-fn))
  126.           (when slots (deallocate-register slots))
  127.           (when csv (deallocate-register csv))))))))
  128.  
  129.  
  130.  
  131. (defun emit-one-index-readers (class-slot-p)
  132.   (declare (type boolean class-slot-p))
  133.   (let ((arglist (list (dfun-arg-symbol 0))))
  134.     (generating-lap '(field cache-vector mask size index miss-fn)
  135.             arglist
  136.       (with-lap-registers ((slots vector))
  137.     (emit-dlap  arglist
  138.             '(standard-instance)
  139.             'trap
  140.             (with-lap-registers ((index index))
  141.               (flatten-lap
  142.             (opcode :move (operand :cvar 'index) index)
  143.             (if class-slot-p
  144.                 (emit-get-class-slot index 'trap slots)
  145.                 (emit-get-slot slots index 'trap))))
  146.             (flatten-lap
  147.               (opcode :label 'trap)
  148.               (emit-miss 'miss-fn))
  149.             nil
  150.             (and (null class-slot-p) (list slots)))))))
  151.  
  152. (defun emit-one-index-writers (class-slot-p)
  153.   (declare (type boolean class-slot-p))
  154.   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
  155.     (generating-lap '(field cache-vector mask size index miss-fn)
  156.             arglist
  157.       (with-lap-registers ((slots vector))
  158.     (emit-dlap arglist
  159.            '(t standard-instance)
  160.            'trap
  161.            (with-lap-registers ((index index))
  162.              (flatten-lap
  163.                (opcode :move (operand :cvar 'index) index)
  164.                (if class-slot-p
  165.                (emit-set-class-slot index (dfun-arg-symbol 0) slots)
  166.                (emit-set-slot slots index (dfun-arg-symbol 0)))))
  167.            (flatten-lap
  168.              (opcode :label 'trap)
  169.              (emit-miss 'miss-fn))
  170.            nil
  171.            (and (null class-slot-p) (list nil slots)))))))
  172.  
  173.  
  174.  
  175. (defun emit-n-n-readers ()
  176.   (let ((arglist (list (dfun-arg-symbol 0))))
  177.     (generating-lap '(field cache-vector mask size miss-fn)
  178.             arglist
  179.       (with-lap-registers ((slots vector)
  180.                (index index))
  181.     (emit-dlap arglist
  182.            '(standard-instance)
  183.            'trap
  184.            (emit-get-slot slots index 'trap)
  185.            (flatten-lap
  186.              (opcode :label 'trap)
  187.              (emit-miss 'miss-fn))
  188.            index
  189.            (list slots))))))
  190.  
  191. (defun emit-n-n-writers ()
  192.   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
  193.     (generating-lap '(field cache-vector mask size miss-fn)
  194.             arglist
  195.       (with-lap-registers ((slots vector)
  196.                (index index))
  197.     (flatten-lap
  198.       (emit-dlap arglist
  199.              '(t standard-instance)
  200.              'trap
  201.              (emit-set-slot slots index (dfun-arg-symbol 0))
  202.              (flatten-lap
  203.                (opcode :label 'trap)
  204.                (emit-miss 'miss-fn))
  205.              index
  206.              (list nil slots)))))))
  207.   
  208.  
  209.  
  210. (defun emit-checking (metatypes applyp)
  211.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
  212.     (generating-lap '(field cache-vector mask size function miss-fn)
  213.             dlap-lambda-list
  214.       (emit-dlap (remove '&rest dlap-lambda-list)
  215.          metatypes         
  216.          'trap
  217.          (with-lap-registers ((function t))
  218.            (flatten-lap
  219.              (opcode :move (operand :cvar 'function) function)
  220.              (opcode :jmp function)))
  221.          (with-lap-registers ((miss-function t))
  222.            (flatten-lap
  223.              (opcode :label 'trap)
  224.              (opcode :move (operand :cvar 'miss-fn) miss-function)
  225.              (opcode :jmp miss-function)))
  226.          nil))))
  227.  
  228. (defun emit-caching (metatypes applyp)
  229.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
  230.     (generating-lap '(field cache-vector mask size miss-fn)
  231.             dlap-lambda-list
  232.       (with-lap-registers ((function t))
  233.     (emit-dlap (remove '&rest dlap-lambda-list)
  234.            metatypes
  235.            'trap
  236.            (flatten-lap (opcode :jmp function))
  237.            (with-lap-registers ((miss-function t))
  238.              (flatten-lap
  239.                (opcode :label 'trap)
  240.                (opcode :move (operand :cvar 'miss-fn) miss-function)
  241.                (opcode :jmp miss-function)))
  242.            function)))))
  243.  
  244. (defun emit-constant-value (metatypes)
  245.   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil)))
  246.     (generating-lap '(field cache-vector mask size miss-fn)
  247.             dlap-lambda-list
  248.       (with-lap-registers ((value t))
  249.     (emit-dlap dlap-lambda-list
  250.            metatypes
  251.            'trap
  252.            (flatten-lap 
  253.              (opcode :return value))
  254.            (with-lap-registers ((miss-function t))
  255.              (flatten-lap
  256.                (opcode :label 'trap)
  257.                (opcode :move (operand :cvar 'miss-fn) miss-function)
  258.                (opcode :jmp miss-function)))
  259.            value)))))
  260.  
  261.  
  262.  
  263. (defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
  264.   (with-lap-registers ((cwrapper #-structure-wrapper vector
  265.                  #+structure-wrapper t))
  266.     (flatten-lap
  267.      (opcode :move (operand :cvar cwrapper-0) cwrapper)
  268.      (opcode :neq wrapper cwrapper miss-label))))        ;wrappers not eq, trap
  269.  
  270. (defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
  271.   (with-lap-registers ((cwrapper #-structure-wrapper vector
  272.                  #+structure-wrapper t))
  273.     (flatten-lap
  274.      (opcode :move (operand :cvar cwrapper-0) cwrapper)        ;This is an OR.  Isn't
  275.      (opcode :eq wrapper cwrapper 'hit-internal)        ;assembly code fun
  276.      (opcode :move (operand :cvar cwrapper-1) cwrapper)        ;
  277.      (opcode :neq wrapper cwrapper miss-label)            ;
  278.      (opcode :label 'hit-internal))))
  279.  
  280. (defun emit-get-slot (slots index trap-label &optional temp)
  281.   (let ((slot-unbound (operand :constant *slot-unbound*)))
  282.     (with-lap-registers ((val t :reuse temp))
  283.       (flatten-lap
  284.     (opcode :move (operand :iref slots index) val)        ;get slot value
  285.     (opcode :eq val slot-unbound trap-label)        ;is the slot unbound?
  286.     (opcode :return val)))))                ;return the slot value
  287.  
  288. (defun emit-set-slot (slots index new-value-arg &optional temp)
  289.   (with-lap-registers ((new-val t :reuse temp))
  290.     (flatten-lap
  291.       (opcode :move (operand :arg new-value-arg) new-val)    ;get new value into a reg
  292.       (opcode :move new-val (operand :iref slots index))    ;set slot value
  293.       (opcode :return new-val))))
  294.  
  295. (defun emit-get-class-slot (index trap-label &optional temp)
  296.   (let ((slot-unbound (operand :constant *slot-unbound*)))
  297.     (with-lap-registers ((val t :reuse temp))
  298.       (flatten-lap
  299.     (opcode :move (operand :cdr index) val)
  300.     (opcode :eq val slot-unbound trap-label)
  301.     (opcode :return val)))))
  302.  
  303. (defun emit-set-class-slot (index new-value-arg &optional temp)
  304.   (with-lap-registers ((new-val t :reuse temp))
  305.     (flatten-lap
  306.       (opcode :move (operand :arg new-value-arg) new-val)
  307.       (opcode :move new-val (operand :cdr index))
  308.       (opcode :return new-val))))
  309.  
  310. (defun emit-miss (miss-fn)
  311.   (with-lap-registers ((miss-fn-reg t))
  312.     (flatten-lap
  313.      (opcode :move (operand :cvar miss-fn) miss-fn-reg)        ;get the miss function
  314.      (opcode :jmp miss-fn-reg))))                ;and call it
  315.  
  316.  
  317.  
  318. (defun dlap-wrappers (metatypes)
  319.   (mapcar #'(lambda (x) (and (neq x 't)
  320.                  (allocate-register #-structure-wrapper 'vector
  321.                         #+structure-wrapper t)))
  322.       metatypes))
  323.  
  324. (defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
  325.   (gathering1 (collecting)
  326.     (iterate ((mt (list-elements metatypes))
  327.           (arg (list-elements args))
  328.           (wrapper (list-elements wrappers))
  329.           (i (interval :from 0)))
  330.        (when wrapper
  331.          (gather1
  332.        (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))))
  333.  
  334. (defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
  335.   (let* ((wrappers (dlap-wrappers metatypes))
  336.      (nwrappers (remove nil wrappers))
  337.      (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
  338.     (prog1 (emit-dlap-internal nwrappers
  339.                    wrapper-moves
  340.                    hit
  341.                    miss
  342.                    miss-label
  343.                    value-reg)
  344.        (mapc #'deallocate-register nwrappers))))
  345.  
  346. (defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
  347.   (cond ((cdr wrapper-regs)
  348.      (emit-greater-than-1-dlap
  349.        wrapper-regs wrapper-moves hit miss miss-label value-reg))
  350.     ((null value-reg)
  351.      (emit-1-nil-dlap
  352.        (car wrapper-regs) (car wrapper-moves) hit miss miss-label))
  353.     (t
  354.      (emit-1-t-dlap
  355.        (car wrapper-regs) (car wrapper-moves) hit miss miss-label value-reg))))
  356.  
  357.  
  358.  
  359. (defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
  360.   (with-lap-registers ((location index)
  361.                (primary index)
  362.                (cache-vector vector))
  363.     (flatten-lap
  364.       wrapper-move
  365.       (opcode :move (operand :cvar 'cache-vector) cache-vector)
  366.       (with-lap-registers ((wrapper-cache-no index))
  367.     (flatten-lap
  368.       (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
  369.       (opcode :move primary location)
  370.       (emit-check-1-wrapper-in-cache cache-vector location wrapper hit)       ;inline hit code
  371.       (opcode :izerop wrapper-cache-no miss-label)))
  372.       (with-lap-registers ((size index))
  373.     (flatten-lap
  374.       (opcode :move (operand :cvar 'size) size)
  375.       (opcode :label 'loop)
  376.       (opcode :move (operand :i1+ location) location)
  377.       (opcode :fix= location primary miss-label)
  378.       (opcode :fix= location size 'set-location-to-min)
  379.       (opcode :label 'continue)
  380.       (emit-check-1-wrapper-in-cache cache-vector location wrapper hit) 
  381.       (opcode :go 'loop)
  382.       (opcode :label 'set-location-to-min)
  383.       (opcode :izerop primary miss-label)
  384.       (opcode :move (operand :constant (index-value->index 0)) location)
  385.       (opcode :go 'continue)))
  386.       miss)))
  387.  
  388. ;;;
  389. ;;; The function below implements CACHE-VECTOR-LOCK-COUNT as the first entry 
  390. ;;; in a cache (svref cache-vector 0).  This should probably be abstracted.
  391. ;;;
  392. (defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
  393.   (with-lap-registers ((location index)
  394.                (primary index)
  395.                (cache-vector vector)
  396.                (initial-lock-count t))
  397.     (flatten-lap
  398.       wrapper-move
  399.       (opcode :move (operand :cvar 'cache-vector) cache-vector)
  400.       (with-lap-registers ((wrapper-cache-no index))
  401.     (flatten-lap
  402.       (emit-1-wrapper-compute-primary-cache-location wrapper primary wrapper-cache-no)
  403.       (opcode :move primary location)
  404.       (opcode :move (operand :cref cache-vector 0) initial-lock-count)       ;get lock-count
  405.       (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
  406.       (opcode :izerop wrapper-cache-no miss-label)))    ;check for obsolescence
  407.       (with-lap-registers ((size index))
  408.     (flatten-lap
  409.       (opcode :move (operand :cvar 'size) size)
  410.  
  411.       (opcode :label 'loop)
  412.       (opcode :move (operand :i1+ location) location)
  413.       (opcode :move (operand :i1+ location) location)
  414.       (opcode :label 'continue)
  415.       (opcode :fix= location primary miss-label)
  416.       (opcode :fix= location size 'set-location-to-min)
  417.       (emit-check-cache-entry cache-vector location wrapper 'hit-internal)
  418.       (opcode :go 'loop)
  419.  
  420.       (opcode :label 'set-location-to-min)
  421.       (opcode :izerop primary miss-label)
  422.       (opcode :move (operand :constant (index-value->index 2)) location)
  423.       (opcode :go 'continue)))
  424.       (opcode :label 'hit-internal)
  425.       (opcode :move (operand :i1+ location) location)           ;position for getting value
  426.       (opcode :move (emit-cache-vector-ref cache-vector location) value)
  427.       (emit-lock-count-test initial-lock-count cache-vector 'hit)
  428.       miss
  429.       (opcode :label 'hit)
  430.       hit)))
  431.  
  432. (defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
  433.   (declare (list wrappers))
  434.   (let ((cache-line-size (compute-line-size
  435.                            (if value
  436.                                (the index (1+ (the index (length wrappers))))
  437.                              (length wrappers)))))
  438.     (declare (type index cache-line-size))
  439.     (with-lap-registers ((location index)
  440.              (primary index)
  441.              (cache-vector vector)
  442.              (initial-lock-count t)
  443.              (next-location index)
  444.              (line-size index))    ;Line size holds a constant
  445.                         ;that can be folded in if there was
  446.                         ;a way to add a constant to 
  447.                         ;an index register
  448.       (flatten-lap
  449.     (apply #'flatten-lap wrapper-moves)
  450.     (opcode :move (operand :constant cache-line-size) line-size)
  451.     (opcode :move (operand :cvar 'cache-vector) cache-vector)
  452.     (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
  453.     (opcode :move primary location)
  454.     (opcode :move location next-location)
  455.     (opcode :move (operand :cref cache-vector 0) initial-lock-count)  ;get the lock-count
  456.     (with-lap-registers ((size index))
  457.       (flatten-lap
  458.         (opcode :move (operand :cvar 'size) size)
  459.         (opcode :label 'continue)
  460.         (opcode :move (operand :i+ location line-size) next-location)
  461.         (emit-check-cache-line cache-vector location wrappers 'hit)
  462.         (emit-adjust-location location next-location primary size 'continue miss-label)
  463.         (opcode :label 'hit)
  464.         (and value (opcode :move (emit-cache-vector-ref cache-vector location) value))
  465.         (emit-lock-count-test initial-lock-count cache-vector 'hit-internal)
  466.         miss
  467.         (opcode :label 'hit-internal)
  468.         hit))))))
  469.  
  470.  
  471.  
  472. ;;;
  473. ;;; Cache related lap code
  474. ;;;
  475.  
  476. (defun emit-check-1-wrapper-in-cache (cache-vector location wrapper hit-code)
  477.   (let ((exit-emit-check-1-wrapper-in-cache 
  478.       (make-symbol "exit-emit-check-1-wrapper-in-cache")))
  479.     (with-lap-registers ((cwrapper #-structure-wrapper vector
  480.                    #+structure-wrapper t))
  481.       (flatten-lap
  482.     (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
  483.     (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
  484.     hit-code
  485.     (opcode :label exit-emit-check-1-wrapper-in-cache)))))
  486.  
  487. (defun emit-check-cache-entry (cache-vector location wrapper hit-label)
  488.   (with-lap-registers ((cwrapper #-structure-wrapper vector
  489.                  #+structure-wrapper t))
  490.     (flatten-lap
  491.       (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
  492.       (opcode :eq cwrapper wrapper hit-label))))
  493.  
  494. (defun emit-check-cache-line (cache-vector location wrappers hit-label)
  495.   (let ((checks
  496.       (flatten-lap
  497.         (gathering1 (flattening-lap)
  498.           (iterate ((wrapper (list-elements wrappers)))
  499.         (with-lap-registers ((cwrapper #-structure-wrapper vector
  500.                            #+structure-wrapper t))
  501.           (gather1
  502.             (flatten-lap
  503.               (opcode :move (emit-cache-vector-ref cache-vector location) cwrapper)
  504.               (opcode :neq cwrapper wrapper 'exit-emit-check-cache-line)
  505.               (opcode :move (operand :i1+ location) location)))))))))
  506.     (flatten-lap
  507.       checks
  508.       (opcode :go hit-label)
  509.       (opcode :label 'exit-emit-check-cache-line))))
  510.  
  511. (defun emit-lock-count-test (initial-lock-count cache-vector hit-label)
  512.   ;;
  513.   ;; jumps to hit-label if cache-vector-lock-count consistent, otherwise, continues
  514.   ;; 
  515.   (with-lap-registers ((new-lock-count t))
  516.     (flatten-lap
  517.       (opcode :move (operand :cref cache-vector 0) new-lock-count) ;get new cache-vector-lock-count
  518.       (opcode :fix= new-lock-count initial-lock-count hit-label))))
  519.  
  520.  
  521.  
  522. (defun emit-adjust-location (location next-location primary size cont-label miss-label)
  523.   (flatten-lap
  524.     (opcode :move next-location location)
  525.     (opcode :fix= location size 'at-end-of-cache)
  526.     (opcode :fix= location primary miss-label)
  527.     (opcode :go cont-label)
  528.     (opcode :label 'at-end-of-cache)
  529.     (opcode :fix= primary (operand :constant (index-value->index 1)) miss-label)
  530.     (opcode :move (operand :constant (index-value->index 1)) location)
  531.     (opcode :go cont-label)))
  532.      
  533.  
  534.  
  535.  
  536.